home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Hardcore Visual Basic 5.0 (2nd Edition)
/
Hardcore Visual Basic 5.0 - Second Edition (1997)(Microsoft Press).iso
/
Code
/
proctool.cls
< prev
next >
Wrap
Text File
|
1997-06-14
|
5KB
|
151 lines
VERSION 1.0 CLASS
BEGIN
MultiUse = -1 'True
END
Attribute VB_Name = "GProcTool"
Attribute VB_GlobalNameSpace = True
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = True
Option Explicit
Public Enum EErrorProcTool
eeBaseProcTool = 13570 ' ProcTool
End Enum
Function TopWndFromProcID(idProcA As Long) As Long
Dim idProc As Long, hWnd As Long
' Get first window
hWnd = GetWindow(GetDesktopWindow(), GW_CHILD)
Do While hWnd <> hNull
' Check instance until it matches
Dim sTitle As String
sTitle = MWinTool.WindowTextLineFromWnd(hWnd)
idProc = MWinTool.ProcIDFromWnd(hWnd)
If idProcA = idProc Then
If MWinTool.IsVisibleTopWnd(hWnd) Then Exit Do
End If
' Get next sibling
hWnd = GetWindow(hWnd, GW_HWNDNEXT)
Loop
TopWndFromProcID = hWnd
End Function
Public Function GetProcInfo(ByVal ID As Long, Optional TabStop As Integer = 0) As String
Dim sStart As String, s As String, sTemp As String
' Nested starting position
sStart = Space$(TabStop * 4)
' Module information
s = sStart & "Program: " & MModTool.ExeNameFromProcID(ID) & sCrLf
s = s & sStart & "Module: " & Hex$(MModTool.ModFromProcID(ID)) & sCrLf
s = s & sStart & "Instance: " & Hex$(MModTool.InstFromProcID(ID)) & sCrLf
s = s & sStart & "PID: " & ID & sCrLf
GetProcInfo = s
End Function
' Pass idProg returned by Shell or ShellPlus
Function IsRunning(ByVal idProg As Long, _
Optional ExitCode As Long) As Boolean
Static hProg As Long
' Get process handle first time through and save it
If hProg = hNull Then
hProg = OpenProcess(PROCESS_QUERY_INFORMATION, False, idProg)
End If
If hProg = hNull Then
' Invalid idProc because program completed before first call
ExitCode = 0
Else
' Got a valid handle so use it to check process status
GetExitCodeProcess hProg, ExitCode
End If
If ExitCode = STILL_ACTIVE Then
IsRunning = True
Else
CloseHandle hProg
End If
End Function
Function WaitOnProgram(ByVal idProg As Long, _
Optional ByVal WaitDead As Boolean) As Long
Dim cRead As Long, iExit As Long, hProg As Long
' Get process handle
hProg = OpenProcess(PROCESS_ALL_ACCESS, False, idProg)
If WaitDead Then
' Stop dead until process terminates
Dim iResult As Long
iResult = WaitForSingleObject(hProg, INFINITE)
If iResult = WAIT_FAILED Then ErrRaise Err.LastDllError
' Get the return value
GetExitCodeProcess hProg, iExit
Else
' Get the return value
GetExitCodeProcess hProg, iExit
' Wait, but allow painting and other processing
Do While iExit = STILL_ACTIVE
DoEvents
GetExitCodeProcess hProg, iExit
Loop
End If
CloseHandle hProg
WaitOnProgram = iExit
End Function
' Combine foreground and background console color attributes
Function ColorAttr(ByVal atrFore As Byte, ByVal atrBack As Byte) As Long
ColorAttr = MBytes.LShiftWord((&HF And atrBack), 4) Or (&HF And atrFore)
End Function
Function VBShellExecute(sFile As String, _
Optional Args As String, _
Optional Show As Long = vbNormalFocus, _
Optional InitDir As String, _
Optional Verb As String, _
Optional hWnd As Long = hNull) As Long
Dim ID As Long
ID = ShellExecute(hWnd, Verb, sFile, Args, InitDir, Show)
' Translate weird ShellExecute errors into normal errors
Select Case ID
Case 0
ID = ERROR_NOT_ENOUGH_MEMORY
Case SE_ERR_SHARE ' 26
ID = ERROR_SHARING_VIOLATION
Case SE_ERR_ASSOCINCOMPLETE ' 27
ID = ERROR_NO_ASSOCIATION
Case SE_ERR_DDETIMEOUT, SE_ERR_DDEFAIL, SE_ERR_DDEBUSY ' 28, 29, 30
ID = ERROR_DDE_FAIL
Case SE_ERR_NOASSOC ' 31
ID = ERROR_NO_ASSOCIATION
Case SE_ERR_DLLNOTFOUND ' 32
ID = ERROR_DLL_NOT_FOUND
Case Is > 32
VBShellExecute = ID
Exit Function
End Select
ApiRaise ID
End Function
#If fComponent = 0 Then
Private Sub ErrRaise(e As Long)
Dim sText As String, sSource As String
If e > 1000 Then
sSource = App.ExeName & ".ProcTool"
Select Case e
Case eeBaseProcTool
BugAssert True
' Case ee...
' Add additional errors
End Select
Err.Raise COMError(e), sSource, sText
Else
' Raise standard Visual Basic error
sSource = App.ExeName & ".VBError"
Err.Raise e, sSource
End If
End Sub
#End If